home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / NEETVGA / RGB / FERN3B.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-26  |  7KB  |  217 lines
  1. {****************************************************************************}
  2. {***********************                              ***********************}
  3. {**                           R-G-B Demonstrator                           **}
  4. {****************************                    ****************************}
  5. {**                       Copyrighted February 12, 1993                    **}
  6. {**                       (C) To Authors                                   **}
  7. {**                             Fernando Padilla                           **}
  8. {**                             Stephen Markham                            **}
  9. {******************************                ******************************}
  10. {****************************************************************************}
  11.  
  12. uses
  13.      roger,crt,fsupvga,graph;
  14. const
  15.      pause=15;
  16.      blendframes=10;
  17.      base=15;
  18.      top=63;
  19. type
  20.      pRGB=(R,RRRG,RRG,RRRGG,RG,RRGGG,RGG,RGGG,G,GGGB,GGB,GGGBB,GB,GGBBB,GBB,GBBB,B,BBBR,BBR,BBBRR,BR,BBRRR,BRR,BRRR,W);
  21.      cRGB=record
  22.           color,
  23.           red,
  24.           green,
  25.           blue:byte;
  26.      end;
  27. var
  28.      buff:char;
  29.  
  30. procedure updatergb(a,b,c,d:integer);
  31. begin
  32.      textcolor(1);
  33.      gotoxy(1,1);
  34.       write('Color:');
  35.       writeln(a:14);
  36.      gotoxy(1,3);
  37.       write('RED:');
  38.       writeln(b:16);
  39.      gotoxy(1,4);
  40.       write('GREEN:');
  41.       writeln(c:14);
  42.      gotoxy(1,5);
  43.       write('BLUE:');
  44.       writeln(d:15);
  45. end;
  46.  
  47.  
  48. Procedure saycolor(a,b,c,d:integer;  updat:boolean);
  49.   function rat(percent,high:byte):integer;
  50.   begin
  51.        rat:=trunc(high*(percent/100));
  52.   end;
  53.   function inverse(a,b:integer):integer;
  54.   begin
  55.        inverse:=abs(a-b);
  56.   end;
  57. begin
  58.      PutColor(a,rat(b,top),rat(c,top),rat(d,top));
  59.      PutColor(a+1,inverse(rat(b,top),top),inverse(rat(c,top),top),inverse(rat(d,top),top));
  60.      if updat then UpdateRGB(a,b,c,d);
  61. end;
  62.  
  63. procedure control(display:boolean);
  64. var
  65.      palette:rogerrgbpalette;
  66.      color:prgb;
  67.      stop:boolean;
  68.   function inverse(a,b:integer):integer;
  69.   begin
  70.        inverse:=abs(a-b);
  71.   end;
  72.   Procedure FadeColor(c:pRGB;  display:boolean;  var stop:boolean);
  73.   var
  74.        percent:byte;
  75.     Procedure DoColor(c:pRGB;  i:byte;  var display,stop:boolean);
  76.     Begin
  77.          if not stop then
  78.          begin
  79.               Case c of
  80.                    R: SayColor(0,i,0,0,display);
  81.                 RRRG: SayColor(0,i,i div 3,0,display);
  82.                  RRG: SayColor(0,i,i div 2,0,display);
  83.                RRRGG: SayColor(0,i,(i*2) div 3,0,display);
  84.                   RG: SayColor(0,i,i,0,display);
  85.                RRGGG: SayColor(0,(i*2) div 3,i,0,display);
  86.                  RGG: SayColor(0,i div 2,i,0,display);
  87.                 RGGG: SayColor(0,i div 3,i,0,display);
  88.                    G: SayColor(0,0,i,0,display);
  89.                 GGGB: SayColor(0,0,i,i div 3,display);
  90.                  GGB: SayColor(0,0,i,i div 2,display);
  91.                GGGBB: SayColor(0,0,i,(i*2) div 3,display);
  92.                   GB: SayColor(0,0,i,i,display);
  93.                GGBBB: SayColor(0,0,(i*2) div 3,i,display);
  94.                  GBB: SayColor(0,0,i div 2,i,display);
  95.                 GBBB: SayColor(0,0,i div 3,i,display);
  96.                    B: SayColor(0,0,0,i,display);
  97.                 BBBR: SayColor(0,i div 3,0,i,display);
  98.                  BBR: SayColor(0,i div 2,0,i,display);
  99.                BBBRR: SayColor(0,(i*2) div 3,0,i,display);
  100.                   BR: SayColor(0,i,0,i,display);
  101.                BBRRR: SayColor(0,i,0,(i*2) div 3,display);
  102.                  BRR: SayColor(0,i,0,i div 2,display);
  103.                 BRRR: SayColor(0,i,0,i div 3,display);
  104.                    W: SayColor(0,i,i,i,display);
  105.               end;
  106.               delay(pause);
  107.               stop:=keypressed;
  108.          end;
  109.     end;
  110.   Begin
  111.        if not stop then
  112.        begin
  113.             For percent := base To 100 Do Docolor(c,percent,display,stop);
  114.             For percent := 100 DownTo base Do Docolor(c,percent,display,stop);
  115.        end;
  116.   end;
  117. Begin
  118.      store(palette);
  119.      stop:=false;
  120.      Repeat
  121.        for color:=R to W do FadeColor(color,display,stop);
  122.      Until KeyPressed or stop;
  123.      Restore(palette);
  124. End;
  125.  
  126. procedure control3(display:boolean);
  127. var
  128.      palette:rogerrgbpalette;
  129.      c:prgb;
  130.      a,d:crgb;
  131.      stop:boolean;
  132.   procedure park(a,b,c,d:integer;  var p:crgb);
  133.   begin
  134.        p.color:=a;
  135.        p.red:=b;
  136.        p.green:=c;
  137.        p.blue:=d;
  138.   end;
  139.   procedure getcolor(c:prgb;  var p:crgb;  i:integer;  var stop:boolean);
  140.   begin
  141.      if not stop then
  142.        Case c of
  143.            R: park(0,i,0,0,p);
  144.         RRRG: park(0,i,i div 3,0,p);
  145.          RRG: park(0,i,i div 2,0,p);
  146.        RRRGG: park(0,i,(i*2) div 3,0,p);
  147.           RG: park(0,i,i,0,p);
  148.        RRGGG: park(0,(i*2) div 3,i,0,p);
  149.          RGG: park(0,i div 2,i,0,p);
  150.         RGGG: park(0,i div 3,i,0,p);
  151.            G: park(0,0,i,0,p);
  152.         GGGB: park(0,0,i,i div 3,p);
  153.          GGB: park(0,0,i,i div 2,p);
  154.        GGGBB: park(0,0,i,(i*2) div 3,p);
  155.           GB: park(0,0,i,i,p);
  156.        GGBBB: park(0,0,(i*2) div 3,i,p);
  157.          GBB: park(0,0,i div 2,i,p);
  158.         GBBB: park(0,0,i div 3,i,p);
  159.            B: park(0,0,0,i,p);
  160.         BBBR: park(0,i div 3,0,i,p);
  161.          BBR: park(0,i div 2,0,i,p);
  162.        BBBRR: park(0,(i*2) div 3,0,i,p);
  163.           BR: park(0,i,0,i,p);
  164.        BBRRR: park(0,i,0,(i*2) div 3,p);
  165.          BRR: park(0,i,0,i div 2,p);
  166.         BRRR: park(0,i,0,i div 3,p);
  167.            W: park(0,i,i,i,p);
  168.        end;
  169.   end;
  170.   function increment(n1,n2,p:integer):integer;
  171.   begin
  172.        increment:=trunc((((n2-n1)/blendframes)*p)+n1);
  173.   end;
  174.   procedure blend(p1,p2:crgb;  var stop,display:boolean);
  175.   var
  176.        a:byte;
  177.   begin
  178.        for a:=0 to blendframes do if not stop then begin saycolor(p1.color,increment(p1.red,p2.red,a),
  179.                                                                            increment(p1.green,p2.green,a),
  180.                                                                            increment(p1.blue,p2.blue,a),display);
  181.                                                  delay(pause);
  182.                                                  stop:=keypressed;
  183.                                            end;
  184.   end;
  185. begin
  186.      store(palette);
  187.      stop:=false;
  188.      getcolor(pred(w),a,0,stop);
  189.      getcolor(r,d,100,stop);
  190.      blend(a,d,stop,display);
  191.      repeat
  192.           for c:=r to pred(pred(w)) do
  193.           begin
  194.                getcolor(c,a,100,stop);
  195.                getcolor(succ(c),d,100,stop);
  196.                blend(a,d,stop,display);
  197.           end;
  198.           getcolor(pred(w),a,100,stop);
  199.           getcolor(r,d,100,stop);
  200.           blend(a,d,stop,display);
  201.      until stop;
  202.      restore(palette);
  203. end;
  204.  
  205. begin
  206.      initializesupvga(0,'c:\tp\bgi');
  207. {     clrscr;
  208.      window(30,11,51,17);}
  209.      cleardevice;
  210.      textmode(font8X8);
  211.      directvideo:=true;
  212.  
  213.      control(not(pos('false',paramstr(1))>0));
  214.      buff:=readkey;
  215.      buff:=readkey;
  216.      control3(not(pos('false',paramstr(1))>0));
  217. end.